home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / http.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  10.6 KB  |  410 lines  |  [TEXT/ALFA]
  1. # Commands covered:  http::config, http::geturl, http::wait, http::reset
  2. #
  3. # This file contains a collection of tests for the http script library.
  4. # Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright (c) 1991-1993 The Regents of the University of California.
  8. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13. #
  14. # SCCS: @(#) http2.test 1.8 97/08/13 11:16:50
  15.  
  16. if {[string compare test [info procs test]] == 1} then {source defs}
  17.  
  18. if {[catch {package require http 2.0}]} {
  19.     if {[info exist http2]} {
  20.     catch {puts stderr "Cannot load http 2.0 package"}
  21.     return
  22.     } else {
  23.     catch {puts stderr "Running http 2.0 tests in slave interp"}
  24.     set interp [interp create http2]
  25.     $interp eval [list set http2 "running"]
  26.     $interp eval [list source [info script]]
  27.     interp delete $interp
  28.     return
  29.     }
  30. }
  31.  
  32. ############### The httpd_ procedures implement a stub http server. ########
  33. proc httpd_init {{port 8015}} {
  34.     socket -server httpdAccept $port
  35. }
  36. proc httpd_log {args} {
  37.     global httpLog
  38.     if {[info exists httpLog] && $httpLog} {
  39.     puts stderr "httpd: [join $args { }]"
  40.     }
  41. }
  42. array set httpdErrors {
  43.     204 {No Content}
  44.     400 {Bad Request}
  45.     404 {Not Found}
  46.     503 {Service Unavailable}
  47.     504 {Service Temporarily Unavailable}
  48.     }
  49.  
  50. proc httpdError {sock code args} {
  51.     global httpdErrors
  52.     puts $sock "$code $httpdErrors($code)"
  53.     httpd_log "error: [join $args { }]"
  54. }
  55. proc httpdAccept {newsock ipaddr port} {
  56.     global httpd
  57.     upvar #0 httpd$newsock data
  58.  
  59.     fconfigure $newsock -blocking 0 -translation {auto crlf}
  60.     httpd_log $newsock Connect $ipaddr $port
  61.     set data(ipaddr) $ipaddr
  62.     fileevent $newsock readable [list httpdRead $newsock]
  63. }
  64.  
  65. # read data from a client request
  66.  
  67. proc httpdRead { sock } {
  68.     upvar #0 httpd$sock data
  69.  
  70.     set readCount [gets $sock line]
  71.     if {![info exists data(state)]} {
  72.     if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
  73.         $line x data(proto) data(url) data(query)] {
  74.         set data(state) mime
  75.         httpd_log $sock Query $line
  76.     } else {
  77.         httpdError $sock 400
  78.         httpd_log $sock Error "bad first line:$line"
  79.         httpdSockDone $sock
  80.     }
  81.     return
  82.     }
  83.  
  84.     # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
  85.  
  86.     set state [string compare $readCount 0],$data(state),$data(proto)
  87.     httpd_log $sock $state
  88.     switch -- $state {
  89.     -1,mime,HEAD    -
  90.     -1,mime,GET    -
  91.     -1,mime,POST    {
  92.         # gets would block
  93.         return
  94.     }
  95.     0,mime,HEAD    -
  96.     0,mime,GET    -
  97.     0,query,POST    { httpdRespond $sock }
  98.     0,mime,POST    { set data(state) query }
  99.     1,mime,HEAD    -
  100.     1,mime,POST    -
  101.     1,mime,GET    {
  102.         if [regexp {([^:]+):[     ]*(.*)}  $line dummy key value] {
  103.         set data(mime,[string tolower $key]) $value
  104.         }
  105.     }
  106.     1,query,POST    {
  107.         append data(query) $line
  108.         httpdRespond $sock
  109.     }
  110.     default {
  111.         if [eof $sock] {
  112.         httpd_log $sock Error "unexpected eof on <$data(url)> request"
  113.         } else {
  114.         httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
  115.         }
  116.         httpdError $sock 404
  117.         httpdSockDone $sock
  118.     }
  119.     }
  120. }
  121. proc httpdSockDone { sock } {
  122. upvar #0 httpd$sock data
  123.     unset data
  124.     close $sock
  125. }
  126.  
  127. # Respond to the query.
  128.  
  129. set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
  130. proc httpdRespond { sock } {
  131.     global httpd bindata port
  132.     upvar #0 httpd$sock data
  133.  
  134.     if {[string match *binary* $data(url)]} {
  135.     set html "$bindata[info hostname]:$port$data(url)"
  136.     set type application/octet-stream
  137.     } else {
  138.     set type text/html
  139.  
  140.     set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
  141. <h1>Hello, World!</h1>
  142. <h2>$data(proto) $data(url)</h2>
  143. "
  144.     if {[info exists data(query)] && [string length $data(query)]} {
  145.         append html "<h2>Query</h2>\n<dl>\n"
  146.         foreach {key value} [split $data(query) &=] {
  147.         append html "<dt>$key<dd>$value\n"
  148.         }
  149.         append html </dl>\n
  150.     }
  151.     append html </body></html>
  152.     }
  153.  
  154.     if {$data(proto) == "HEAD"} {
  155.     puts $sock "HTTP/1.0 200 OK"
  156.     } else {
  157.     puts $sock "HTTP/1.0 200 Data follows"
  158.     }
  159.     puts $sock "Date: [clock format [clock clicks]]"
  160.     puts $sock "Content-Type: $type"
  161.     puts $sock "Content-Length: [string length $html]"
  162.     puts $sock ""
  163.     if {$data(proto) != "HEAD"} {
  164.     fconfigure $sock -translation binary
  165.     puts -nonewline $sock $html
  166.     }
  167.     httpd_log $sock Done ""
  168.     httpdSockDone $sock
  169. }
  170. ##################### end server ###########################
  171.  
  172. set port 8010
  173. if [catch {httpd_init $port} listen] {
  174.     puts stderr "Cannot start http server, http test skipped"
  175.     unset port
  176.     return
  177. }
  178.  
  179. test http-1.1 {http::config} {
  180.     http::config
  181. } {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}}
  182.  
  183. test http-1.2 {http::config} {
  184.     http::config -proxyfilter
  185. } http::ProxyRequired
  186.  
  187. test http-1.3 {http::config} {
  188.     catch {http::config -junk}
  189. } 1
  190.  
  191. test http-1.4 {http::config} {
  192.     set savedconf [http::config]
  193.     http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
  194.     set x [http::config]
  195.     eval http::config $savedconf
  196.     set x
  197. } {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
  198.  
  199. test http-1.5 {http::config} {
  200.     catch {http::config -proxyhost {} -junk 8080}
  201. } 1
  202.  
  203. test http-2.1 {http::reset} {
  204.     catch {http::reset http#1}
  205. } 0
  206.  
  207. test http-3.1 {http::geturl} {
  208.     catch {http::geturl -bogus flag}
  209. } 1
  210. test http-3.2 {http::geturl} {
  211.     catch {http::geturl http:junk} err
  212.     set err
  213. } {Unsupported URL: http:junk}
  214.  
  215. set url [info hostname]:$port
  216. test http-3.3 {http::geturl} {
  217.     set token [http::geturl $url]
  218.     http::data $token
  219. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  220. <h1>Hello, World!</h1>
  221. <h2>GET /</h2>
  222. </body></html>"
  223.  
  224. set tail /a/b/c
  225. set url [info hostname]:$port/a/b/c
  226. set binurl [info hostname]:$port/binary
  227.  
  228. test http-3.4 {http::geturl} {
  229.     set token [http::geturl $url]
  230.     http::data $token
  231. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  232. <h1>Hello, World!</h1>
  233. <h2>GET $tail</h2>
  234. </body></html>"
  235.  
  236. proc selfproxy {host} {
  237.     global port
  238.     return [list [info hostname] $port]
  239. }
  240. test http-3.5 {http::geturl} {
  241.     http::config -proxyfilter selfproxy
  242.     set token [http::geturl $url]
  243.     http::config -proxyfilter http::ProxyRequired
  244.     http::data $token
  245. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  246. <h1>Hello, World!</h1>
  247. <h2>GET http://$url</h2>
  248. </body></html>"
  249.  
  250. test http-3.6 {http::geturl} {
  251.     http::config -proxyfilter bogus
  252.     set token [http::geturl $url]
  253.     http::config -proxyfilter http::ProxyRequired
  254.     http::data $token
  255. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  256. <h1>Hello, World!</h1>
  257. <h2>GET $tail</h2>
  258. </body></html>"
  259.  
  260. test http-3.7 {http::geturl} {
  261.     set token [http::geturl $url -headers {Pragma no-cache}]
  262.     http::data $token
  263. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  264. <h1>Hello, World!</h1>
  265. <h2>GET $tail</h2>
  266. </body></html>"
  267.  
  268. test http-3.8 {http::geturl} {
  269.     set token [http::geturl $url -query Name=Value&Foo=Bar]
  270.     http::data $token
  271. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  272. <h1>Hello, World!</h1>
  273. <h2>POST $tail</h2>
  274. <h2>Query</h2>
  275. <dl>
  276. <dt>Name<dd>Value
  277. <dt>Foo<dd>Bar
  278. </dl>
  279. </body></html>"
  280.  
  281. test http-3.9 {http::geturl} {
  282.     set token [http::geturl $url -validate 1]
  283.     http::code $token
  284. } "HTTP/1.0 200 OK"
  285.  
  286.  
  287. test http-4.1 {http::Event} {
  288.     set token [http::geturl $url]
  289.     upvar #0 $token data
  290.     array set meta $data(meta)
  291.     expr ($data(totalsize) == $meta(Content-Length))
  292. } 1
  293.  
  294. test http-4.2 {http::Event} {
  295.     set token [http::geturl $url]
  296.     upvar #0 $token data
  297.     array set meta $data(meta)
  298.     string compare $data(type) [string trim $meta(Content-Type)]
  299. } 0
  300.  
  301. test http-4.3 {http::Event} {
  302.     set token [http::geturl $url]
  303.     http::code $token
  304. } {HTTP/1.0 200 Data follows}
  305.  
  306. test http-4.4 {http::Event} {
  307.     set out [open testfile w]
  308.     set token [http::geturl $url -channel $out]
  309.     close $out
  310.     set in [open testfile]
  311.     set x [read $in]
  312.     close $in
  313.     file delete testfile
  314.     set x
  315. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  316. <h1>Hello, World!</h1>
  317. <h2>GET $tail</h2>
  318. </body></html>"
  319.  
  320. test http-4.5 {http::Event} {
  321.     set out [open testfile w]
  322.     set token [http::geturl $url -channel $out]
  323.     close $out
  324.     upvar #0 $token data
  325.     file delete testfile
  326.     expr $data(currentsize) == $data(totalsize)
  327. } 1
  328.  
  329. test http-4.6 {http::Event} {
  330.     set out [open testfile w]
  331.     set token [http::geturl $binurl -channel $out]
  332.     close $out
  333.     set in [open testfile]
  334.     fconfigure $in -translation binary
  335.     set x [read $in]
  336.     close $in
  337.     file delete testfile
  338.     set x
  339. } "$bindata$binurl"
  340.  
  341. proc myProgress {token total current} {
  342.     global progress httpLog
  343.     if {[info exists httpLog] && $httpLog} {
  344.     puts "progress $total $current"
  345.     }
  346.     set progress [list $total $current]
  347. }
  348. if 0 {
  349.     # This test hangs on Windows95 because the client never gets EOF
  350.     set httpLog 1
  351.     test http-4.6 {http::Event} {
  352.     set token [http::geturl $url -blocksize 50 -progress myProgress]
  353.     set progress
  354.     } {111 111}
  355. }
  356. test http-4.7 {http::Event} {
  357.     set token [http::geturl $url -progress myProgress]
  358.     set progress
  359. } {111 111}
  360. test http-4.8 {http::Event} {
  361.     set token [http::geturl $url]
  362.     http::status $token
  363. } {ok}
  364. test http-4.9 {http::Event} {
  365.     set token [http::geturl $url -progress myProgress]
  366.     http::code $token
  367. } {HTTP/1.0 200 Data follows}
  368. test http-4.10 {http::Event} {
  369.     set token [http::geturl $url -progress myProgress]
  370.     http::size $token
  371. } {111}
  372. test http-4.11 {http::Event} {
  373.     set token [http::geturl $url -timeout 1 -command {#}]
  374.     http::reset $token
  375.     http::status $token
  376. } {reset}
  377. test http-4.12 {http::Event} {
  378.     set token [http::geturl $url -timeout 1 -command {#}]
  379.     http::wait $token
  380.     http::status $token
  381. } {timeout}
  382.  
  383. test http-5.1 {http::formatQuery} {
  384.     http::formatQuery name1 value1 name2 "value two"
  385. } {name1=value1&name2=value+two}
  386.  
  387. test http-5.2 {http::formatQuery} {
  388.     http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
  389. } {name1=%7ebwelch&name2=%a1%a2%a2}
  390.  
  391. test http-5.3 {http::formatQuery} {
  392.     http::formatQuery lines "line1\nline2\nline3"
  393. } {lines=line1%0d%0aline2%0d%0aline3}
  394.  
  395. test http-6.1 {http::ProxyRequired} {
  396.     http::config -proxyhost [info hostname] -proxyport $port
  397.     set token [http::geturl $url]
  398.     http::wait $token
  399.     http::config -proxyhost {} -proxyport {}
  400.     upvar #0 $token data
  401.     set data(body)
  402. } "<html><head><title>HTTP/1.0 TEST</title></head><body>
  403. <h1>Hello, World!</h1>
  404. <h2>GET http://$url</h2>
  405. </body></html>"
  406.  
  407. unset url
  408. unset port
  409. close $listen
  410.